VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmGeneric 
   Caption         =   "Generic form"
   ClientHeight    =   3825
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   6015
   OleObjectBlob   =   "frmGeneric.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "frmGeneric"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' version 7.7
' frmGeneric functions
' Copyright 2011 potato.peelings@gmail.com



Const constControlHeight As Integer = 20
Const constTopMargin As Integer = 20
Const constMaxControls As Integer = 7

Public boolWasClosed As Boolean
Private boolNoScreenRefresh As Boolean
Private strControlArray As String



' get values
Sub sShowGenericForm(strFormAttributes, strTargetRange, strControlString, boolParamNoScreenRefresh)
On Error GoTo Error_Handler
    ' global screen refresh parameter
    boolNoScreenRefresh = boolParamNoScreenRefresh

    ' clear the form
    Call sClearControls
    
    ' get the number of controls
    arrControls = Split(strControlString, Chr(10))
    intControls = UBound(arrControls) + 1
    
    
    ' set the form properties
    arrFormAttributes = Split(strFormAttributes & ";;", ";")            ' width and height are optional
    
    ' set caption and button text
    arrFormLabels = Split(arrFormAttributes(0) & ":Submit", ":")
    frmGeneric.Caption = arrFormLabels(0)
    frmGeneric.btnSubmit.Caption = arrFormLabels(1)
    
    ' set width. the width map is
    ' .image=60.20.labelWidth.10.controlWidth.40
    If Trim(arrFormAttributes(1)) <> "" Then                            ' user defined widths
        arrWidths = Split(arrFormAttributes(1), ":")
        intLabelWidth = fMax(arrWidths(0) - 30, 50)
        intControlWidth = fMax(arrWidths(1) - 40, 125)
    Else
        intLabelWidth = 50                                              ' default widths
        intControlWidth = 125
    End If
    frmGeneric.Width = 130 + intLabelWidth + intControlWidth
    
    ' wrap long labels, count extra rows and check for controls
    boolHasInputControls = False
    intExtraOptionRows = 0
    intExtraLabelWrapRows = 0
    Controls.Add "Forms.Label.1", "LabelFit", True
    Controls("LabelFit").AutoSize = True
    Controls("LabelFit").Height = 15
    Controls("LabelFit").WordWrap = False
    
    For i = 0 To intControls - 1
        ' convert blank lines to label;
        If Trim(arrControls(i)) = "" Then
            arrControls(i) = "Label;"
        End If
        
        ' check for input controls
        If LCase(Left(arrControls(i), 5)) <> "label" Then
            boolHasInputControls = True
        Else
        ' lines to wrap the label text
        ' from http://stackoverflow.com/questions/257458#257458
            Controls("LabelFit").Caption = Split(arrControls(i), ";")(1)
            
            ' the control wraps
            If Controls("LabelFit").Width > (frmGeneric.Width - 100) Then
                strCaptionText = Controls("LabelFit").Caption
                arrControls(i) = "Label;"
                strCaptionLine = ""
                intLastDelimiterLocation = -1
                
                ' move through the caption
                For j = 1 To Len(strCaptionText)
                    strChar = Mid(strCaptionText, j, 1)
                    Controls("LabelFit").Caption = strCaptionLine & strChar
                    
                    ' does the label wrap at this point?
                    If Controls("LabelFit").Width > (frmGeneric.Width - 100) Then
                        ' -1 indicates we haven't come across a delimiter in this line yet
                        ' so dump the whole line
                        If intLastDelimiterLocation = -1 Then
                            intLastDelimiterLocation = Len(strCaptionLine) + 1
                        End If
                        
                        intExtraLabelWrapRows = intExtraLabelWrapRows + 1
                        ' 2 line wraps make the label wrap lines have the same vertical spacing as normal controls
                        arrControls(i) = arrControls(i) & Mid(strCaptionLine, 1, intLastDelimiterLocation) & vbCrLf & vbCrLf
                        strCaptionLine = Mid(strCaptionLine, intLastDelimiterLocation + 1) & Trim(strChar)
                        
                        ' reset the delimiter location
                        intLastDelimiterLocation = -1
                    Else
                        strCaptionLine = strCaptionLine & strChar
                    End If
                
                    ' note delimiter positions
                    If InStr(1, " ;,.?", strChar) <> 0 Then
                        intLastDelimiterLocation = Len(strCaptionLine)
                    End If
                Next
                
                arrControls(i) = arrControls(i) & strCaptionLine
            End If
        End If
    
        ' each radio option after the 1st adds a row to the form
        If LCase(Left(arrControls(i), 5)) = "radio" Then
            arrControlMeta = Split(arrControls(i), ";")
            strListAddress = Mid(arrControlMeta(1), InStr(1, arrControlMeta(1), ":") + 1)
            intExtraOptionRows = intExtraOptionRows + ExcelBricks.fGetRangeFromCell(strListAddress).Count - 1
        End If
    Next
    
    Controls.Remove "LabelFit"
    intFormRows = intControls + intExtraOptionRows + intExtraLabelWrapRows
    
    ' if there are input controls, the target range must not be blank
    If boolHasInputControls And Trim(strTargetRange) = "" Then
        Err.Raise ExcelBricks.lngFullError, , "Forms with input controls must have a destination location."
    ElseIf boolHasInputControls Then
        Set objTargetRange = fGetRange(strTargetRange)
    End If
    
    
    ' set height
    boolNoFitHeight = (LCase(Trim(arrFormAttributes(2))) <> "fit")
    If intFormRows <= constMaxControls And boolNoFitHeight Then
        frmGeneric.Height = constControlHeight * constMaxControls + 90
    Else
        frmGeneric.Height = constControlHeight * intFormRows + 90       ' height depends on number of controls
    End If
    Image1.Height = frmGeneric.Height
    
    
    ' button position
    frmGeneric.btnSubmit.Top = frmGeneric.Height - 55
    frmGeneric.btnSubmit.Left = frmGeneric.Width - 80
    
    ' starting position
    intTopPosition = constTopMargin
    ' push controls down if the number of controls is less
    If intFormRows <= constMaxControls And boolNoFitHeight Then
        intTopPosition = intTopPosition + (constMaxControls - intFormRows) * constControlHeight
    End If


    ' layout controls
    strControlArray = ""
    
    For i = 0 To intControls - 1
        arrControlMeta = Split(arrControls(i), ";")
        If UBound(arrControlMeta) < 1 Then
            Err.Raise ExcelBricks.lngFullError, , "Unrecognized control format [" & arrControls(i) & "]"
        End If
        
        arrControlMeta(0) = LCase(arrControlMeta(0))
        strLabel = Mid(arrControlMeta(1), 1, InStr(1, arrControlMeta(1) & ":", ":") - 1)
        strListAddress = Mid(arrControlMeta(1), Len(strLabel) + 2)
        
        ' set caption properties
        Controls.Add "Forms.Label.1", "Label" & i, True
        With Controls("Label" & i)
            .Caption = strLabel
            .Left = 80
            .WordWrap = False
            .Top = intTopPosition
        
            If arrControlMeta(0) = "label" Then
                .Width = frmGeneric.Width - 100
                
                ' check if there are any line breaks (introduced for wrapping)
                intCountLines = (Len(.Caption) - Len(Replace(.Caption, vbCrLf, ""))) / 4 + 1
                If (intCountLines <> 1) Then
                    ' increase the height of the label so that it shows all lines
                    ' you need an additional vertical offset for the extra lines
                    Controls("Label" & i).Height = intCountLines * constControlHeight
                    intTopPosition = intTopPosition + (intCountLines - 1) * constControlHeight
                End If
            Else
                ' get the default value for controls
                strDefaultValue = objTargetRange.Offset(i, 0).Value
                
                .Width = intLabelWidth
                        
                ' mandatory field have bold red labels
                ' checkboxes cannot be mandatory
                If Right(.Caption, 1) = "*" Then
                    If arrControlMeta(0) = "checkbox" Then
                        Err.Raise ExcelBricks.lngFullError, , "Checkboxes cannot be mandatory."
                    End If
                    .ForeColor = 255
                    .FontBold = True
                End If
            End If
        End With
        
        ' create the control
        Select Case (arrControlMeta(0))
        Case "radio"
            ' add options
            intOption = 0
            intTopPosition = intTopPosition - constControlHeight
            
            For Each objCell In ExcelBricks.fGetRangeFromCell(strListAddress).Cells
                intTopPosition = intTopPosition + constControlHeight
                
                strName = fAddControl("OptionButton", i & "." & intOption, 90 + intLabelWidth, intTopPosition - 2)
                
                Controls(strName).Caption = objCell.Value
                Controls(strName).GroupName = "Control" & i
                Controls(strName).Value = ((Controls(strName).Caption = strDefaultValue) Or (intOption = 0))
                
                intOption = intOption + 1
            Next
            
        Case "checkbox"
            fAddControl "CheckBox", i, 90 + intLabelWidth, Controls("Label" & i).Top - 2
            Controls("Control" & i).Value = (strDefaultValue = True)
        
        Case "password"
            fAddControl "TextBox", i, 90 + intLabelWidth, intTopPosition
            Controls("Control" & i).PasswordChar = "*"
            
        Case "pulldown"
            fAddControl "ComboBox", i, 90 + intLabelWidth, intTopPosition
            Controls("Control" & i).Style = 2
            With ExcelBricks.fGetRangeFromCell(strListAddress)
                Controls("Control" & i).RowSource = "'" & .Worksheet.Name & "'!" & .Address
            End With
            
        Case "textbox"
            fAddControl "TextBox", i, 90 + intLabelWidth, intTopPosition
        
        Case "label"
        ' don't do anything; this just passes on invalid controls to the else part
        
        Case Else
            Err.Raise ExcelBricks.lngFullError, , "Unrecognized control [" & arrControlMeta(0) & "]"
        End Select
        
        ' set the control properties
        If arrControlMeta(0) <> "label" And _
            arrControlMeta(0) <> "radio" And _
            arrControlMeta(0) <> "checkbox" Then
            Controls("Control" & i).Width = intControlWidth
            Controls("Control" & i).Height = 15
            Controls("Control" & i).BorderStyle = 1
            Controls("Control" & i).Value = strDefaultValue
        End If
        
        intTopPosition = intTopPosition + constControlHeight
    Next
    
    
    ' set focus on the first control
    ' we must use the control array, since the first row could have been a label
    If strControlArray <> "" Then
        strControlArray = Mid(strControlArray, 2)
        Call Controls(Split(strControlArray, Chr(10))(0)).SetFocus
    End If


    boolWasClosed = False
    If Not (boolNoScreenRefresh) Then
        Application.ScreenUpdating = True
    End If
    Call ExcelBricks.sPauseClock
    Show
    Call ExcelBricks.sContinueClock
    Application.ScreenUpdating = False
    
    
    ' exit with a message
    If boolWasClosed Then
        ExcelBricks.strGlobalErrDescription = "Form closed. Ending run."
        Err.Raise ExcelBricks.lngShowGlobal
    Else
        
        ' set values
        For Each i In Split(strControlArray, Chr(10))
            
            ' not a radio button
            If InStr(1, i, ".") = 0 Then
                intIndex = Replace(i, "Control", "")
                objTargetRange.Offset(intIndex, 0).Value = Controls(i).Value
                
            ' this is a radio button and this is the selected one
            ElseIf Controls(i).Value = True Then
                intIndex = Replace(i, "Control", "")
                intIndex = Mid(intIndex, 1, InStr(1, intIndex, ".") - 1)
                objTargetRange.Offset(intIndex, 0).Value = Controls(i).Caption
            End If
        Next
    End If
    
Error_Handler:
    If Err.Number <> 0 Then
        strErrDescription = Err.Description
        lngErrNumber = Err.Number
    End If
    
    On Error Resume Next
    ' cleanup
    Set objTargetRange = Nothing
    On Error GoTo 0
    
    If lngErrNumber <> 0 Then Err.Raise lngErrNumber, , strErrDescription
End Sub


' submit data
Private Sub btnSubmit_Click()

    ' check to see if any mandatory fields are missing values
    For Each i In Split(strControlArray, Chr(10))
        
        ' skip radio buttons - they will always have a value
        If InStr(1, i, ".") = 0 Then
            intIndex = Replace(i, "Control", "")
           
            ' if this is a mandatory field with missing values
            If Controls("Label" & intIndex).FontBold = True And _
                Controls(i).Value = "" Then
                MsgBox "Please fill all mandatory fields", vbExclamation
                Exit Sub
            End If
        End If
    Next
    
    Me.Hide
    
    ' force a screen update
    If Not boolNoScreenRefresh Then
        Application.ScreenUpdating = True
    End If
End Sub


' closed by clicing the cancel button
Private Sub btnCancel_Click()
    Unload Me
End Sub

' when closed
Private Sub UserForm_Terminate()
    boolWasClosed = True
End Sub


' clear all the controls and labels
Private Sub sClearControls()
    For Each i In frmGeneric.Controls
        If i.Name <> "btnSubmit" And i.Name <> "btnCancel" And i.Name <> "Image1" Then
            Controls.Remove i.Name
        End If
    Next
End Sub


' get maximum
Private Function fMax(intA, intB)
    If intA > intB Then
        fMax = intA
    Else
        fMax = intB
    End If
End Function


' add a control and set common properties
Private Function fAddControl(strType, strNameSuffix, intLeft, intTop)
    strName = "Control" & strNameSuffix
    
    Controls.Add "Forms." & strType & ".1", strName, True
    Controls(strName).Left = intLeft
    Controls(strName).Top = intTop
    strControlArray = strControlArray & Chr(10) & strName
    
    fAddControl = strName
End Function
